/*
 * @progname       ps-anc2
 * @version        2.0
 * @author         Wheeler
 * @category       
 * @output         PostScript
 * @description    
**  
**  This LifeLines report program generates Postscript ancestral and
**  descendant charts.  The ancestral charts can include the siblings
**  of all direct ancestors (aunts, uncles, great-aunts, great-uncles,
**  etc.).  A multi-page poster chart can also be generated.  The
**  chart format is based on the program GedChart, by Tom Blumer.
** 
**  ps-anc2, 16 August 1994, by Fred Wheeler (wheeler@ipl.rpi.edu)
**  
**  GETTING THIS FILE
**  
**  This file is available via anonymous ftp from
**   (1) ftp://ipl.rpi.edu/pub/wheeler/ps-anc1
**   (2) ftp://hoth.stsci.edu/lines/reports/ps-anc1
**   (3) ftp://ftp.cac.psu.edu/pub/genealogy/lines/reports/ps-anc1
**  It was uploaded to (1) on the date above, and will appear at (2)
**  and (3) soon after.  If you cannot ftp it, I will e-mail it to you.
**  
**  BRIEF DESCRIPTION
**  
**  This LifeLines report program generates Postscript ancestral and
**  descendant charts.  The ancestral charts can include the siblings
**  of all direct ancestors (aunts, uncles, great-aunts, great-uncles,
**  etc.).  A multi-page poster chart can also be generated.  The
**  chart format is based on the program GedChart, by Tom Blumer.
**  
**  The Postscript file created can be sent to any size printer; it
**  will automatically adapt the size of the chart.  I send the same
**  file to A-size (8.5 by 11) and B-size (11 by 17) printers.
**  
**  After you use this program a few times, you should edit the
**  function interrogate_user().  This is the first function after
**  these comments and the global variable declarations.  This
**  function is set up to make it easy for you to configure what
**  questions this program should ask you each time and what default
**  values it should use for questions not asked.
**  
**  Please contact me if you like this program, find any bugs, have
**  any bug fixes, or want to suggest improvements.  I am also always
**  on the lookout for better ancestral/descendant chart generating
**  programs.  If you know of a program that generates charts which
**  you like better than those generated by this program, please drop
**  me a line.
**  
**  This report program works with the LifeLines Genealogical database
**  program only.  (see ftp://ftp.cac.psu.edu/pub/genealogy/lines/*)
**  
**  CHANGE LOG
**  
**  Changes since version 1:
**    Completely new descendant chart in addition to ancestral chart
**    Multi-page poster option
**    Multi-page charts scaled correctly (thanks to broman@Np.nosc.mil)
**    Maximum name length configurable by user (fixes long squashed names)
**    Option to supress siblings of later generations in ancestral charts
**    Checks that user selects a valid person (bug fix)
**    Can make a guess at whether a title is a prefix of suffix type
**    Use of titles is configurable (prefix, suffix, guess, none)
**    Birth/death/marriage date styles are configurable (may include place)
**    Corner message is slightly smaller, and chart will not overlap it
**    Marriage date is printed before death date
**    Tabs converted to spaces and all lines made < 80 chars
**
**  CREDITS
**
**  Code improvements recieved from:
**    Vincent Broman (broman@Np.nosc.mil)
**
**  Helpful comments recieved from:
**    Vincent Broman (broman@Np.nosc.mil)
**    Frank H. Flaesland (phranx@imr.no)
**    Linda Wilson (lwilson@mcc.com)
**    Stacy Johnson (sjohnson@oucsace.cs.ohiou.edu)
**    John F. Chandler (jchbn@cuvmb.cc.columbia.edu)
**    Susan Radel
**
**  ABOUT GEDCHART (a different program)
**
**  This program includes postscript code written by Tom Blumer
**  (blumer@ptltd.com).  It is used here with his permission.  This
**  postscript code is from Tom Blumer's GedChart package.  The report
**  is very much like that generated by GedChart using the -Sa or -Sd
**  option.
**
**  GedChart is DOS program that generates ancestral and descendant
**  charts like this report program, and also fan charts.  GedChart
**  works directly from a GEDCOM file and is completely independent of
**  LifeLines.  It is currently up to version 1.6, which is a beta
**  version that may lead to a commercial product.  You can find
**  GedChart at ftp:oak.oakland.edu/pub/msdos/genealgy/gedcht16.zip
**
*/

global (high_pos_gen)     /* array, highest so far in each generation */
global (high_pos_all)     /* highest position so far for any generation */

global (name_height)      /* height of name text on chart */
global (date_height)      /* height of birth/death/marriage date text */

global (no_parent_extra)  /* constant, extra vert. line when no parent */

/* variables prompted from or configured by the user */

global (chart_type)       /* int, 0: ancestral, 1: descendant */
global (root_person)      /* indi, person for whom to generate the chart */
global (font_name)        /* string, name of font */
global (max_depth)        /* int, maximum number of generations */
global (chart_label)      /* string, label for corner of chart */
global (color_chart)      /* boolean, is chart in color */
global (multi_page)       /* boolean, is chart many page poster type */
global (x_pages)          /* int, number of horizontal pages */
global (y_pages)          /* int, number of vertical pages */
global (name_letters)     /* int, maximum number of letters in a name */
global (title_method)     /* int, code for how to insert titles */
global (depth_siblings)   /* int, number of generations to show siblings */
global (dateplace_birth)  /* int, date style for birth/death/marriage */
global (dateplace_death)
global (dateplace_marriage)

/* variables to return values from procedures to make them functions */
global (do_anc_stack)     /* stack, function do_anc is recursive */
global (person_height_return)
global (is_prefix_title_return)
global (dateplace_return)

/* these three constants define how close branches of the tree can get */
global (branch_dist_prev)  /* minimum distance from previous generation */
global (branch_dist_same)  /* minimum distance from same generation */
global (branch_dist_next)  /* minimum distance from next generation */

/* stacks for storing the information for each person on the chart */
/* see proc's enqueue_person and dequeue_all_persons */

global (plist_person)  /* the person (to extract name, birth, death) */
global (plist_depth)   /* generation depth */
global (plist_pos)     /* vertical position */
global (plist_line)    /* 0,1 boolean, is direct ancestor? */
global (plist_mdate)   /* marriage date */

/* stacks for storing the information for each vertical line on the chart */
/* see proc's enqueue_vertical and dequeue_all_verticals */

global (llist_depth)   /* generation depth */
global (llist_low)     /* starting point */
global (llist_high)    /* finishing point */

/*
**  procedure: interrogate_user
**
**  This procedure is designed to be modified by the user.  It asks
**  many questions about how to configure the charts.  If your answer
**  to one of the questions is always the same, you can easily
**  hardwire your answer here so that you are never asked again.
**
**  An 'if' statement is wrapped around each question.  The 'if (1)'
**  can be changed to an 'if (0)' to make the program use the default
**  value defined in the 'else' clause instead of asking every time.
**
*/

proc interrogate_user ()
{

/*
**  QUESTION: What type of chart?
**
**  This should always be asked, unless you never use one of the two
**  types of charts.
**
*/

  if (1)  {
    getintmsg (chart_type,
               "Enter 0 for ancestral, 1 for descendant chart")
  }  else  {
    set (chart_type, 1)
  }

/*
**  QUESTION: Who is the root person?
**
**  This question should always be asked, unless you always use the same
**  person, which is not likely.  If you do set a default, it is a string
**  representation of that persons number.
**
*/

  if (1)  {
    set (root_person, 0)
    while ( not (root_person) )  {
      getindimsg (root_person, "Identify root person for chart")
    }
  }  else  {
    set (root_person, indi ("1"))
  }

/*
**  QUESTION: How many generations should be shown?
**
**  This should always be explicitly asked.
**
*/

  if (1)  {
    getintmsg (max_depth, "Maximum number of generations")
  }  else  {
    set (max_depth, 5)
  }

/*
**  QUESTION: How many generations should show siblings?
**
**  If you want to show siblings in all generations, set this default to 999.
**  This question is only asked for ancestral charts.
**
*/

  if (eq (chart_type, 0))  {

    if (0)  {
      getintmsg (depth_siblings, "How many generations to show siblings")
    }  else  {
      set (depth_siblings, 999)
    }

  }

/*
**  QUESTION: What message should be shown in the corner of the chart?
**
**  I suggest not asking this question, and setting a default credit with
**  your name.  The advantage of this is that you can have the date
**  automatically inserted.
**
*/

  if (1)  {
    getstrmsg (chart_label, "Label for corner of chart (your name, date)")
    set (chart_label, save (chart_label))
  }  else  {
    dayformat (2)
    monthformat (6)
    dateformat (0)
    set (chart_label,
      concat ("by Frederick W. Wheeler, ", save (stddate (gettoday ()))))
  }

/*
**  QUESTION: What font should be used?
**
**  Because it is such a pain to enter a font name, and a spelling mistake
**  will get you an ugly default font, this should be set to a default.  I
**  suggest one of: Times-Roman, NewCenturySchlbk-Roman, or ZapfChancery.
**  Search the Postscript code at bottom of this file for a longer list.
**
*/

  if (0)  {
    getstrmsg (font_name,
      "Font (Times-Roman, NewCenturySchlbk-Roman, ZapfChancery, etc.")
    set (font_name, save (font_name))
  }  else  {
    set (font_name, "Times-Roman")
  }

/*
**  QUESTION: Should color be used?
**
**  If you don't have access to a color printer, you should probably turn
**  off this question.
**
*/

  if (1)  {
    getintmsg (color_chart, "Enter 0 for black/white, 1 for color")
  }  else  {
    set (color_chart, 0)
  }

/*
**  QUESTION: Do you want multi-page poster output?
**
**  So that I am not hassled with this question everytime I run this
**  program, I turn this question off, but change the default on the
**  special occasion that I want a poster chart.
**
*/

  if (1)  {
    getintmsg (multi_page, "Enter 0 for single page, 1 for multipage")
  }  else  {
    set (multi_page, 0)
  }

/*
**  QUESTION: How many pages make up the poster?
**
**  You will probably want to always ask this question.  This question is
**  asked if a poster chart is requested.
**
*/

  if (multi_page)  {

    if (1)  {
      getintmsg (x_pages, "Number of horizontal pages")
      getintmsg (y_pages, "Number of vertical pages")
    }  else  {
      set (x_pages, 3)
      set (y_pages, 3)
    }

  }  else  {
    set (x_pages, 1)
    set (y_pages, 1)
  }

/*
**  QUESTION: How should titles be used?
**
**  I would leave this default set to 'guess' (3), or 'none' (0), if you
**  don't want the titles.  If find a title that is guessed incorrectly,
**  please send an e-mail to wheeler@ipl.rpi.edu.
**
*/

  if (0)  {
    getintmsg (title_method,
               "Title method (0:none,1:prefix,2:suffix,3:guess)")
  }  else  {
    set (title_method, 3)
  }

/*
**  QUESTION: What is the maximum length for names?
**
**  It is best to just set a default maximum name length.  If you want
**  to always show the complete name, just set the default to 999.
**
*/

  if (0)  {
    getintmsg (name_letters, "Maximum name length")
  }  else  {
    set (name_letters, 40)
  }

/*
**  QUESTION: How should dates/places of birth/death/marriage be shown?
**
**  This is actually three questions, or the same question for birth
**  death and marriage dates.  The codes cause the dates to be printed
**  as follows.
**
**      0: do not show date
**      1: full date only
**         [ LifeLines date() function ]
**      2: date and place, just year and State/Country
**         [ LifeLines short() function ]
**      3: full date and full place, can get very long and thus smushed
**         [ LifeLines long() function ]
**
*/

  if (0)  {
    set (dateplace_birth, 99)
    while (or (lt (dateplace_birth, 0), ge (dateplace_birth, 4)))  {
      getintmsg (dateplace_birth,
                 "Birth date style (0:no,1:date,2:short,3:long)")
    }
    set (dateplace_death, 99)
    while (or (lt (dateplace_death, 0), ge (dateplace_death, 4)))  {
      getintmsg (dateplace_death,
                 "Death date style (0:no,1:date,2:short,3:long)")
    }
    set (dateplace_marriage, 99)
    while (or (lt (dateplace_marriage, 0),
               ge (dateplace_marriage, 4)))  {
      getintmsg (dateplace_marriage,
                 "Marriage date style (0:no,1:date,2:short,3:long)")
    }
  }  else  {
    set (dateplace_birth, 1)
    set (dateplace_death, 1)
    set (dateplace_marriage, 1)
  }

/*
**  END OF QUESTIONS
**
*/

}

/*
**  procedure: main
**
**  The main procedure.
**
*/

proc main ()
{

  /* set constants */

  set (name_height, 1300)        /* height to allow for name text */
  set (date_height, 750)         /* height to allow for date text */

  set (branch_dist_prev, 1200)   /* previous generation */
  set (branch_dist_same, 1500)   /* same generation */
  set (branch_dist_next, 1200)   /* next generation */

  set (no_parent_extra, 600)     /* a little extra line when no parent */

  /* initialize other global variables and declare global stacks */

  set (high_pos_all, 0)

  list (high_pos_gen)
  list (do_anc_stack)

  list (plist_person)
  list (plist_depth)
  list (plist_pos)
  list (plist_line)
  list (plist_mdate)

  list (llist_depth)
  list (llist_low)
  list (llist_high)

  call interrogate_user ()

  /* covert the numerical response for color to "true" or "false" */

  if (eq (color_chart, 0))  {
    set (color_true_false, "false")
  }  else  {
    set (color_true_false, "true")
  }

  /* start iteration that creates the chart */

  if (eq (chart_type, 0))  {
    call do_anc (root_person, 1, 0, 0)
  }  else  {
    call do_des (root_person, 1)
  }

  /* put the pieces together to make the output file */

  set (xi, 1)
  while ( le (xi, x_pages))  {
    set (yi, 1)
    while ( le (yi, y_pages))  {

      call print_header (font_name, max_depth, high_pos_all,
                         color_true_false, chart_label,
                         xi, x_pages, yi, y_pages)
      call dequeue_all_persons ()
      call dequeue_all_verticals ()
      "showpage" nl()

      set (yi, add (yi, 1))
    }
    set (xi, add (xi, 1))
  }

}

/*
**  procedure: do_anc
**
**  A recursive function to position persons on an ancestral chart.
**  First, a recursive call is made to put the father on the chart.
**  Where he is put on the chart determines the minimum position for
**  the mother.  Once the father and mother are put on the chart, the
**  siblings are put on the chart.
**
**  The position of the person is returned via the global stack
**  do_anc_stack.  A stack is necessary since this procedure is
**  reentrant.
**
*/

proc do_anc (person, depth, min_pos_arg, marriage_date)
{
  /* don't want to modify procedure argument variable, so copy it */

  set (min_pos, min_pos_arg)

  /* figure out number of siblings and total sibling height */
  /* done differently, depending on whether the parents family exists */

  set (fam, parents (person))
  if ( and ( fam, le (depth, depth_siblings) ) )  {

    set (sibling_height, 0)
    children (fam, child, unused_number)  {
      call person_height (child)
      set (sibling_height, add (sibling_height, person_height_return))
    }
    set (num_siblings, nchildren (fam))

  }  else  {

    call person_height (child)
    set (sibling_height, person_height_return)
    set (num_siblings, 1)

  }

  /* add extra width for marriage date of male ancestor, if it is known */

  if (marriage_date)  {
    set (sibling_height, add (sibling_height, date_height))
  }

  /* make sure minimum position is greater than zero */

  if (lt (min_pos, 0))  {
    set (min_pos, 0)
  }

  /* do not overlap another branch at the younger generation */

  if (gt (depth, 1))  {
    if (high, getel (high_pos_gen, sub (depth, 1)))  {
      if (lt (min_pos, add (high, branch_dist_prev)))  {
        set (min_pos, add (high, branch_dist_prev))
      }
    }
  }

  /* do not overlap another branch at the same generation */

  if (high, getel (high_pos_gen, depth))  {
    if (lt (min_pos, add (high, branch_dist_same)))  {
      set (min_pos, add (high, branch_dist_same))
    }
  }

  /* do not overlap another branch at the older generation */

  if (lt (depth, max_depth))  {
    if (high, getel (high_pos_gen, add (depth, 1)))  {
      if (lt (min_pos, add (high, branch_dist_next)))  {
        set (min_pos, add (high, branch_dist_next))
      }
    }
  }

  /* do father if he exists and is not too deep */

  set (dad_min_pos, sub (min_pos, name_height))
  set (dad_pos, dad_min_pos)
  set (did_dad, 0)                  /* boolean, is dad on the chart */

  if (lt (depth, max_depth))  {
    if (par, father (person))  {
      call dateplace (marriage (parents (person)), dateplace_marriage)
      if (dateplace_return)  {
        call do_anc (par, add (depth, 1), dad_min_pos, dateplace_return)
      }  else  {
        call do_anc (par, add (depth, 1), dad_min_pos, 0)
      }
      set (dad_pos, pop (do_anc_stack))
      set (did_dad, 1)
    }
  }

  if (lt (min_pos, add (dad_pos, name_height)))  {
    set (min_pos, add (dad_pos, name_height))
  }

  /* do mother if she exists and is not too deep */

  set (mom_min_pos, add (add (dad_pos, name_height), sibling_height))
  set (mom_pos, mom_min_pos)
  set (did_mom, 0)                  /* boolean, is mom on the chart */

  if (lt (depth, max_depth))  {
    if (par, mother (person))  {
      call do_anc (par, add (depth, 1), mom_min_pos, 0)
      set (mom_pos, pop (do_anc_stack))
      set (did_mom, 1)
    }
  }

  /* find the spacer needed to line up siblings between parents */

  set (delta, sub (mom_pos, add (dad_pos, name_height)))
  set (extra, sub (delta, sibling_height))
  set (spacer, div (extra, add (num_siblings, 1)))

  set (pos, add (dad_pos, name_height))
  set (pos, add (pos, spacer))

  /* position siblings, differently depending on whether parents exist */

  if (fam, parents (person))  {

    if ( le (depth, depth_siblings))  {

      children (fam, child, number)  {

        /* if this is the ancestor, return the position and use marriage */

        if (eq (child, person))  {
          call enqueue_person (child, depth, pos, 1, marriage_date)
          push (do_anc_stack, pos)
        }  else  {
          call enqueue_person (child, depth, pos, 0, 0)
        }

        /* store the positions of the first and last children */

        if (eq (number, 1))  {
          set (first_pos, pos)
        }
        if (eq (number, nchildren (fam)))  {
          set (last_pos, pos)
        }

        /* increment position by height of person plus the spacer */

        call person_height (child)
        set (pos, add (pos, person_height_return))
        if (and (eq (child, person), marriage_date))  {
          set (pos, add (pos, date_height))
        }
        set (pos, add (pos, spacer))
      }

    }  else  {

      call enqueue_person (person, depth, pos, 1, marriage_date)
      push (do_anc_stack, pos)

      /* this may cause a line of zero length to be drawn */
      set (first_pos, pos)
      set (last_pos, pos)

      /* increment position by height of person plus the spacer */

      call person_height (person)
      set (pos, add (pos, person_height_return))
      if (marriage_date)  {
        set (pos, add (pos, date_height))
      }
      set (pos, add (pos, spacer))
    }

    /* if father is on the chart, he determines the vertical line start */
    /* otherwise, the oldest sibling does */

    if (eq (did_dad, 1))  {
      set (line_start, dad_pos)
    }  else  {
      set (line_start, sub (first_pos, no_parent_extra))
    }

    /* note: line_start may be < 0, that is OK */

    /* if mother is on the chart, she determines the vertical line end */
    /* otherwise, the youngest sibling does */

    if (eq (did_mom, 1))  {
      set (line_end, mom_pos)
    }  else  {
      set (line_end, add (last_pos, no_parent_extra))
    }

    /* print vert. line if parent or any siblings are on the chart */

    if (or (or (did_mom, did_dad), gt (nchildren (fam), 1)))  {
      call enqueue_vertical (depth, line_start, line_end)
      /* update highest overall position */
      if (lt (high_pos_all, add (line_end, name_height)))  {
        set (high_pos_all, add (line_end, name_height))
      }
    }

  }  else  {

    /* else, if the person has no visible siblings */

    call enqueue_person (person, depth, pos, 1, marriage_date)
    push (do_anc_stack, pos)

    /* increment position by height of person plus the spacer */

    call person_height (person)
    set (pos, add (pos, person_height_return))
    if (marriage_date)  {
      set (pos, add (pos, date_height))
    }
    set (pos, add (pos, spacer))
  }

  /* update the highest position array, or set it for the first time */

  if (high, getel (high_pos_gen, depth))  {
    if (lt (high, pos))  {
      setel (high_pos_gen, depth, pos)
    }
  }  else  {
    setel (high_pos_gen, depth, pos)
  }

  /* update the overall highest position */

  if (lt (high_pos_all, pos))  {
    set (high_pos_all, pos)
  }
}

/*
**  procedure: do_des
**
**  A recursive function to position persons on a descendant chart.
**
*/

proc do_des (person, depth)
{
  /* don't want to modify procedure argument variable, so copy it */

  set (min_pos, min_pos_arg)

  set (make_line, 0)

  if (female (person))  {

    families (person, fam, spouse, num)  {
      set (make_line, 1)
      if (eq (num, 1))  {
        set (line_top, high_pos_all)
      }
      call dateplace (marriage (fam), dateplace_marriage)
      set (mdate, dateplace_return)
      if (spouse)  {
        call enqueue_person (spouse, depth, high_pos_all, 0, mdate)
        call person_height (spouse)
        set (high_pos_all, add (high_pos_all, person_height_return))
        if (mdate)  {
          set (high_pos_all, add (high_pos_all, date_height))
        }
      }  else  {
        set (high_pos_all, add (high_pos_all, name_height))
      }
      if (lt (depth, max_depth))  {
        children (fam, child, cn)  {
          call do_des (child, add (depth, 1))
        }
      }
    }
    call enqueue_person (person, depth, high_pos_all, 1, 0)
    set (line_bot, high_pos_all)
    call person_height (person)
    set (high_pos_all, add (high_pos_all, person_height_return))

  }  else  {

    call enqueue_person (person, depth, high_pos_all, 1, 0)
    set (line_top, high_pos_all)
    call person_height (person)
    set (high_pos_all, add (high_pos_all, person_height_return))
    families (person, fam, spouse, num)  {
      set (make_line, 1)
      if (lt (depth, max_depth))  {
        children (fam, child, cn)  {
          call do_des (child, add (depth, 1))
        }
      }
      call dateplace (marriage (fam), dateplace_marriage)
      set (mdate, dateplace_return)
      set (line_bot, high_pos_all)
      if (spouse)  {
        call enqueue_person (spouse, depth, high_pos_all, 0, mdate)
        call person_height (spouse)
        set (high_pos_all, add (high_pos_all, person_height_return))
        if (mdate)  {
          set (high_pos_all, add (high_pos_all, date_height))
        }
      }  else  {
        set (high_pos_all, add (high_pos_all, name_height))
      }
    }
  }

  if (make_line)  {
    call enqueue_vertical (depth, line_top, line_bot)
  }
}

/*
**  procedure: dateplace
**
**  Get the date of an event in the appropriate style (which may include
**  the place.  Return via global variable.
**
*/

proc dateplace (ev, style)
{
  if (eq (style, 0))  {
    set (dateplace_return, 0)
  }
  if (eq (style, 1))  {
    set (dateplace_return, save (date (ev)))
  }
  if (eq (style, 2))  {
    set (dateplace_return, save (short (ev)))
  }
  if (eq (style, 3))  {
    set (dateplace_return, save (long (ev)))
  }
  if (ge (style, 4))  {
    print ("error: invalid date style code")
  }
}

/*
**  procedure: person_height
**
**  Return the height of a single persons entry.  Only the name, and
**  birth and death dates are considered.  The name is assumed to be in
**  the database, the dates are checked for.  The marriage date is not
**  checked for here.  It is more tricky since it is only put below the
**  father's name and you have to make sure you have the date from the
**  right marriage.
**
**  The height of the person is returned via the global variable
**  person_height_return.  This global variable is used since LifeLines
**  does not yet provide user-defined functions.
**
*/

proc person_height (person)
{
  set (person_height_return, name_height)

  call dateplace (birth (person), dateplace_birth)
  if (dateplace_return)  {
    set (person_height_return, add (person_height_return, date_height))
  }

  call dateplace (death (person), dateplace_death)
  if (dateplace_return)  {
    set (person_height_return, add (person_height_return, date_height))
  }
}

/*
**  procedure: is_prefix_title
**
**  Decide if the given title is a prefix type title.  Returns boolean
**  response in global variable is_prefix_title_return.
**
*/

proc is_prefix_title (t)
{
  set (is_prefix_title_return, 0)

  if (index (t, "Mr", 1))      { set (is_prefix_title_return, 1) }
  if (index (t, "Mrs", 1))     { set (is_prefix_title_return, 1) }
  if (index (t, "Ms", 1))      { set (is_prefix_title_return, 1) }
  if (index (t, "Miss", 1))    { set (is_prefix_title_return, 1) }
  if (index (t, "Dr", 1))      { set (is_prefix_title_return, 1) }
  if (index (t, "Prof", 1))    { set (is_prefix_title_return, 1) }
  if (index (t, "Hon", 1))     { set (is_prefix_title_return, 1) }
  if (index (t, "Judge", 1))   { set (is_prefix_title_return, 1) }
  if (index (t, "Brot", 1))    { set (is_prefix_title_return, 1) }
  if (index (t, "Sis", 1))     { set (is_prefix_title_return, 1) }
  if (index (t, "Deacon", 1))  { set (is_prefix_title_return, 1) }
  if (index (t, "Fr", 1))      { set (is_prefix_title_return, 1) }
  if (index (t, "Father", 1))  { set (is_prefix_title_return, 1) }
  if (index (t, "Mons", 1))    { set (is_prefix_title_return, 1) }
  if (index (t, "Msgr", 1))    { set (is_prefix_title_return, 1) }
  if (index (t, "Arch", 1))    { set (is_prefix_title_return, 1) }
  if (index (t, "Bish", 1))    { set (is_prefix_title_return, 1) }
  if (index (t, "Card", 1))    { set (is_prefix_title_return, 1) }
  if (index (t, "Pope", 1))    { set (is_prefix_title_return, 1) }
  if (index (t, "Lord", 1))    { set (is_prefix_title_return, 1) }
  if (index (t, "Baron", 1))   { set (is_prefix_title_return, 1) }
  if (index (t, "Duke", 1))    { set (is_prefix_title_return, 1) }
  if (index (t, "Princ", 1))   { set (is_prefix_title_return, 1) }
  if (index (t, "Lady", 1))    { set (is_prefix_title_return, 1) }
  if (index (t, "Queen", 1))   { set (is_prefix_title_return, 1) }
  if (index (t, "King", 1))    { set (is_prefix_title_return, 1) }
  if (index (t, "Pres", 1))    { set (is_prefix_title_return, 1) }
  if (index (t, "Sen", 1))     { set (is_prefix_title_return, 1) }
  if (index (t, "Cong", 1))    { set (is_prefix_title_return, 1) }
  if (index (t, "Rep", 1))     { set (is_prefix_title_return, 1) }
}

/*
**  procedure: enqueue_person
**
**  Store the data for a person in the global lists.  It will be
**  printed later.
**
*/

proc enqueue_person (person, depth, pos, line, mdate)
{
  enqueue (plist_person, person)
  enqueue (plist_depth,  depth)
  enqueue (plist_pos,    pos)
  enqueue (plist_line,   line)
  enqueue (plist_mdate,  mdate)
}

/*
**  procedure: dequeue_all_persons
**
**  Dequeue and print all persons stored in the global lists.  The
**  lines are stored in a second queue as they are printed and then
**  placed back in the original, global, queue.
**
*/

proc dequeue_all_persons ()
{
  list (tlist_person)
  list (tlist_depth)
  list (tlist_pos)
  list (tlist_line)
  list (tlist_mdate)

  while (person, dequeue (plist_person))  {
    set (depth,  dequeue (plist_depth))
    set (pos,    dequeue (plist_pos))
    set (line,   dequeue (plist_line))
    set (mdate,  dequeue (plist_mdate))

    call print_person (person, depth, pos, line, mdate)

    enqueue (tlist_person, person)
    enqueue (tlist_depth,  depth)
    enqueue (tlist_pos,    pos)
    enqueue (tlist_line,   line)
    enqueue (tlist_mdate,  mdate)
  }

  while (person, dequeue (tlist_person))  {
    set (depth,  dequeue (tlist_depth))
    set (pos,    dequeue (tlist_pos))
    set (line,   dequeue (tlist_line))
    set (mdate,  dequeue (tlist_mdate))

    enqueue (plist_person, person)
    enqueue (plist_depth,  depth)
    enqueue (plist_pos,    pos)
    enqueue (plist_line,   line)
    enqueue (plist_mdate,  mdate)
  }
}

/*
**  procedure: print_person
**
**  Print a line of data for a person in postscript format.  Each line
**  printed is essentially a call to a postscript function defined in the
**  header.
**
*/

proc print_person (person, depth, pos, line, mdate)
{

  if (eq (title_method, 0))  {
    set (prefix_title, 0)
    set (suffix_title, 0)
  }
  if (eq (title_method, 1))  {
    set (prefix_title, title (person))
    set (suffix_title, 0)
  }
  if (eq (title_method, 2))  {
    set (prefix_title, 0)
    set (suffix_title, title (person))
  }
  if (eq (title_method, 3))  {
    set (prefix_title, 0)
    set (suffix_title, 0)
    if (t, title (person))  {
      call is_prefix_title (t)
      if (is_prefix_title_return)  {
        set (prefix_title, t)
      }  else  {
        set (suffix_title, t)
      }
    }
  }

  set (nlet, name_letters)
  if (prefix_title)  {
    set (nlet, sub (nlet, strlen (prefix_title)))
  }
  if (suffix_title)  {
    set (nlet, sub (nlet, strlen (suffix_title)))
  }

  /* print name and title, if it exists */
  "("
  if (prefix_title)  {
    prefix_title " "
  }
  fullname (person, 0, 1, nlet)
  if (suffix_title)  {
    " " suffix_title
  }
  ")"

  /* print birth date, if it exists */
  call dateplace (birth (person), dateplace_birth)
  if (dateplace_return)  {
    " (b. " dateplace_return ")"
  }  else  {
    " ()"
  }

  /* print marriage date, if it exists */
  if (mdate)  {
    " (m. " mdate ")"
  }  else  {
    " ()"
  }

  /* optional special tagged note, not used yet */
  " ()"

  /* print death date, if it exists */
  call dateplace (death (person), dateplace_death)
  if (dateplace_return)  {
    " (d. " dateplace_return ")"
  }  else  {
    " ()"
  }

  /* print generation, 0=youngest */
  " " d (sub (depth, 1))

  /* print vertical position */
  " " call print_thousandths (pos)

  /* extra height, not used or understood */
  " 1"

  /* 1=direct ancestor, 0=sibling */
  " " d (line)

  /* duplicate individual, not used */
  " 0"

  /* call postscript function to process and print this data */
  " i"

  nl()
}

/*
**  procedure: enqueue_vertical
**
**  Enqueue the data for a single vertical line onto the global lists.
**
*/

proc enqueue_vertical (depth, low, high)
{
  enqueue (llist_depth,  depth)
  enqueue (llist_low,    low)
  enqueue (llist_high,   high)
}

/*
**  procedure: dequeue_all_verticals
**
**  Dequeue and print all vertical lines.  The lines are stored in a
**  second queue as they are printed and then placed back in the
**  original, global, queue.
**
*/

proc dequeue_all_verticals ()
{
  list (tlist_depth)
  list (tlist_low)
  list (tlist_high)

  while (depth,  dequeue (llist_depth))  {
    set (low,    dequeue (llist_low))
    set (high,   dequeue (llist_high))

    call print_vertical (depth, low, high)

    enqueue (tlist_depth, depth)
    enqueue (tlist_low,   low)
    enqueue (tlist_high,  high)
  }

  while (depth,  dequeue (tlist_depth))  {
    set (low,    dequeue (tlist_low))
    set (high,   dequeue (tlist_high))

    enqueue (llist_depth, depth)
    enqueue (llist_low,   low)
    enqueue (llist_high,  high)
  }
}

/*
**  procedure: print_vertical
**
**  Print a single vertical line to link a married couple or siblings.
**
*/

proc print_vertical (depth, low, high)
{
  d (sub (depth, 1))
  " " call print_thousandths (low)
  " " call print_thousandths (high)
  " l" nl()
}

/*
**  procedure: print_thousandths
**
**  Since LifeLines does not offer a floating point type, decimal
**  computation is done using integers that represent thousands.  This
**  procedure converts a number in thousandths to decimal notation and
**  prints it.  The length of the decimal part is checked to make sure
**  it is padded with zeros correctly.
**
*/

proc print_thousandths (n_arg)
{

  /* don't want to modify proc argument, so copy it */
  set (n, n_arg)

  if (lt (n, 0))  {
    "-"
    set (n, neg (n))
  }

  d (div (n, 1000)) "."

  set (t, d (mod (n, 1000)))
  if (eq (strlen (t), 1))  {
    "00" t
  }
  if (eq (strlen (t), 2))  {
    "0" t
  }
  if (eq (strlen (t), 3))  {
    t
  }

}

/*
**  procedure: print_header
**
**  Arguments:
**    fn:  font name
**    md:  maximum level, integer
**    mp:  maximum position, integer in thousandths
**    ctf: color true/false, string "true" or "false"
**    cl:  chart label, string
**    xi:  which horizontal page
**    xn:  number of horizontal pages
**    yi:  which vertical page
**    yn:  number of vertical pages
**
**  Print the initial postscript code.  This code will likely be the
**  bulk of the output file.  It prints the border, defines postscript
**  functions for printing peoples names, dates and the lines on the
**  chart, and more.  It will be followed by the data.
**
**  This postscript code was written by Thomas P. Blumer (blumer@ptltd.com).
**  The only modification is where data from the arguments is inserted.
**
*/

proc print_header (fn, ml, mp, ctf, cl, xi, xn, yi, yn)
{
  "%!PS-Adobe-2.0 EPSF-1.2" nl()
  "%%BoundingBox:0 0 612 792" nl()
  "/#copies 1 def" nl()
  "/xpages " d (xn) " def" nl()
  "/ypages " d (yn) " def" nl()
  "/xpage " d (xi) " def" nl()
  "/ypage " d (yi) " def" nl()
  "/maxlevel " d (ml) " def" nl()
  "/mirror false def" nl()
  "/maxpos " call print_thousandths (mp)  nl()
  "0.02 ypages div 1.0 add mul def" nl()
  "/color " ctf " def" nl()
  "/bold false def" nl()
  "/indent 3.00 def" nl()
  "/linwidf 1.000 def" nl()
  "/font_adjust 1.000 def" nl()
  "/offset_name 0.000 def" nl()
  "% Put PostScript code here to print a label on the chart" nl()
  "/inch {72 mul} def" nl()
  "/chart_label {" nl()
  "  .15 inch .15 inch moveto" nl()
  "  fontname findfont 7 scalefont setfont" nl()
  "  (" cl ") show" nl()
  "} def" nl()
  "/lr 0 def /lg 1 def /lb 1 def" nl()
  "/Lr 0 def /Lg 0 def /Lb 1 def" nl()
  "/tr 0 def /tg 0 def /tb 0 def" nl()
  "/Tr 0 def /Tg 0 def /Tb 0 def" nl()
  "/lmr 0 def /lmg 1 def /lmb 1 def" nl()
  "/Lmr 0 def /Lmg 0 def /Lmb 1 def" nl()
  "/tmr 0 def /tmg 0 def /tmb 0 def" nl()
  "/Tmr 0 def /Tmg 0 def /Tmb 0 def" nl()
  "/fontname /" fn " def" nl()
  "/encvec [" nl()
  "16#80 /Ccedilla" nl()
  "16#81 /udieresis" nl()
  "16#82 /eacute" nl()
  "16#83 /acircumflex" nl()
  "16#84 /adieresis" nl()
  "16#85 /agrave" nl()
  "16#86 /aring" nl()
  "16#87 /ccedilla" nl()
  "16#88 /ecircumflex" nl()
  "16#89 /edieresis" nl()
  "16#8a /egrave" nl()
  "16#8b /idieresis" nl()
  "16#8c /icircumflex" nl()
  "16#8d /igrave" nl()
  "16#8e /Adieresis" nl()
  "16#8f /Aring" nl()
  "16#90 /Eacute" nl()
  "16#91 /ae" nl()
  "16#92 /AE" nl()
  "16#93 /ocircumflex" nl()
  "16#94 /odieresis" nl()
  "16#95 /ograve" nl()
  "16#96 /ucircumflex" nl()
  "16#97 /ugrave" nl()
  "16#98 /ydieresis" nl()
  "16#99 /Odieresis" nl()
  "16#9a /Udieresis" nl()
  "16#9b /cent" nl()
  "16#9c /sterling" nl()
  "16#9d /yen" nl()
  "16#9f /florin" nl()
  "16#a0 /aacute" nl()
  "16#a1 /iacute" nl()
  "16#a2 /oacute" nl()
  "16#a3 /uacute" nl()
  "16#a4 /ntilde" nl()
  "16#a5 /Ntilde" nl()
  "16#a6 /ordfeminine" nl()
  "16#a7 /ordmasculine" nl()
  "16#a8 /questiondown" nl()
  "16#aa /logicalnot" nl()
  "16#ab /onehalf" nl()
  "16#ac /onequarter" nl()
  "16#ad /exclamdown" nl()
  "16#ae /guillemotleft" nl()
  "16#af /guillemotright" nl()
  "16#f8 /degree" nl()
  "16#f9 /bullet" nl()
  "16#fa /periodcentered" nl()
  "] def" nl()
  "% Copyright (c) 1991-1993 Thomas P. Blumer." nl()
  "% All Rights Reserved." nl()
  "% Permission granted to use in LifeLines report generation." nl()
  "/border true def" nl()
  nl()
  "color {" nl()
  "  /setcmykcolor where { pop" nl()
  "    Tr Tg Tb add add 0 eq {" nl()
  "      /Tk 1 def" nl()
  "    } {" nl()
  "      /Tk 0 def" nl()
  "      /Tr 1 Tr sub def /Tg 1 Tg sub def /Tb 1 Tb sub def" nl()
  "    } ifelse" nl()
  nl()
  "    tr tg tb add add 0 eq {" nl()
  "      /tk 1 def" nl()
  "    } {" nl()
  "      /tk 0 def" nl()
  "      /tr 1 tr sub def /tg 1 tg sub def /tb 1 tb sub def" nl()
  "    } ifelse" nl()
  nl()
  "    Lr Lg Lb add add 0 eq {" nl()
  "      /Lk 1 def" nl()
  "    } {" nl()
  "      /Lk 0 def" nl()
  "      /Lr 1 Lr sub def /Lg 1 Lg sub def /Lb 1 Lb sub def" nl()
  "    } ifelse" nl()
  nl()
  "    lr lg lb add add 0 eq {" nl()
  "      /lk 1 def" nl()
  "    } {" nl()
  "      /lk 0 def" nl()
  "      /lr 1 lr sub def /lg 1 lg sub def /lb 1 lb sub def" nl()
  "    } ifelse" nl()
  nl()
  "    /textcolr0 {Tr Tg Tb Tk setcmykcolor} bind def" nl()
  "    /textcolr1 {tr tg tb tk setcmykcolor} bind def" nl()
  "    /lincolr0 {Lr Lg Lb Lk setcmykcolor} bind def" nl()
  "    /lincolr1 {lr lg lb lk setcmykcolor} bind def" nl()
  "  } {" nl()
  "    /textcolr0 {Tr Tg Tb setrgbcolor} bind def" nl()
  "    /textcolr1 {tr tg tb setrgbcolor} bind def" nl()
  "    /lincolr0 {Lr Lg Lb setrgbcolor} bind def" nl()
  "    /lincolr1 {lr lg lb setrgbcolor} bind def" nl()
  "  } ifelse" nl()
  "} {" nl()
  "  /textcolr0 {} bind def" nl()
  "  /textcolr1 {} bind def" nl()
  "  /lincolr0 {} bind def" nl()
  "  /lincolr1 {} bind def" nl()
  "} ifelse" nl()
  nl()
  "% table of how to get bold fonts" nl()
  "/bolddict 25 dict def" nl()
  "bolddict begin" nl()
  nl()
  "% default table entry is that boldfontname = fontname" nl()
  "fontname fontname def" nl()
  nl()
  "/Courier /Courier-Bold def" nl()
  "/Courier-Oblique /Courier-BoldOblique def" nl()
  "/Times-Roman /Times-Bold def" nl()
  "/Times-Italic /Times-BoldItalic def" nl()
  "/Helvetica /Helvetica-Bold def" nl()
  "/Helvetica-Oblique /Helvetica-BoldOblique def" nl()
  "/Bookman-Light /Bookman-Demi def" nl()
  "/Bookman-LightItalic /Bookman-DemiItalic def" nl()
  "/Palatino-Roman /Palatino-Bold def" nl()
  "/Palatino-Italic /Palatino-BoldItalic def" nl()
  "/AvantGarde-Book /AvantGarde-Demi def" nl()
  "/AvantGarde-BookOblique /AvantGarde-DemiOblique def" nl()
  "/Helvetica-Narrow /Helvetica-Narrow-Bold def" nl()
  "/Helvetica-Narrow-Oblique /Helvetica-Narrow-BoldOblique def" nl()
  "/Helvetica-Condensed /Helvetica-Condensed-Bold def" nl()
  "/Helvetica-Condensed-Oblique /Helvetica-Condensed-BoldObl def" nl()
  "/NewCenturySchlbk-Roman /NewCenturySchlbk-Bold def" nl()
  "/NewCenturySchlbk-Italic /NewCenturySchlbk-BoldItalic def" nl()
  "/ZapfChancery /ZapfChancery-Bold def" nl()
  "end" nl()
  nl()
  "/boldfontname fontname def" nl()
  "/boldfontname bolddict fontname get def" nl()
  nl()
  "% get printable area" nl()
  "clippath pathbbox newpath" nl()
  "/ury exch def /urx exch def" nl()
  "/lly exch def /llx exch def" nl()
  nl()
  "% adjust for PacificPage cartridge" nl()
  "statusdict /product known {" nl()
  "  statusdict begin product end (PacificPage) eq" nl()
  "  version (4.06) eq and {" nl()
  "    /lly lly 5 add def" nl()
  "    /ury ury 10 sub def" nl()
  "  } if" nl()
  "} if" nl()
  nl()
  "% set portrait mode, get width and height" nl()
  "/wp urx llx sub def" nl()
  "/hp ury lly sub def" nl()
  "/w wp xpages mul def" nl()
  "/h hp ypages mul def" nl()
  "wp hp lt {" nl()
  "  % portrait mode" nl()
  "  llx lly translate" nl()
  "} {" nl()
  "  % landscape mode" nl()
  "   /tmp hp def" nl()
  "  /hp wp def" nl()
  "  /wp tmp def" nl()
  "   /tmp h def" nl()
  "  /h w def" nl()
  "  /w tmp def" nl()
  "  urx lly translate 90 rotate" nl()
  "} ifelse" nl()
  nl()
  "% multi page output" nl()
  "xpages 1 ne ypages 1 ne or {" nl()
  "  1 xpage sub wp mul  1 ypage sub hp mul  translate" nl()
  "} if" nl()
  nl()
  "% decorative border" nl()
  "border {" nl()
  "  /bwid1 2.5 def" nl()
  "  /gapwid 1.5 def" nl()
  "  /bwid2 0.7 def" nl()
  "  /rect {" nl()
  "    /rh exch def" nl()
  "    /rw exch def" nl()
  "    moveto" nl()
  "    rw 0 rlineto" nl()
  "    0 rh rlineto" nl()
  "    rw neg 0 rlineto" nl()
  "    closepath stroke" nl()
  "  } def" nl()
  nl()
  "  bwid1 setlinewidth" nl()
  "  lincolr0" nl()
  "  bwid1 2 div  dup  w bwid1 sub  h bwid1 sub  rect" nl()
  nl()
  "  bwid2 setlinewidth" nl()
  "  bwid1 gapwid bwid2 2 div add add  dup" nl()
  "  w bwid1 2 mul sub gapwid 2 mul sub bwid2 sub " nl()
  "  h bwid1 2 mul sub gapwid 2 mul sub bwid2 sub rect" nl()
  nl()
  "  % cut the border out of the imageable area" nl()
  "  /tmp bwid1 gapwid bwid2 gapwid add add add def" nl()
  "  tmp tmp translate" nl()
  "  /w w tmp 2 mul sub def" nl()
  "  /h h tmp 2 mul sub def" nl()
  "} if" nl()
  nl()
  "% for multi page: only label bottom left page" nl()
  "/chart_label where xpage 1 eq ypage 1 eq and and {" nl()
  "  pop" nl()
  "  gsave" nl()
  "  % set up coordinate system for custom chart label" nl()
  "  clippath pathbbox newpath pop pop translate" nl()
  "  chart_label" nl()
  "  grestore" nl()
  "} if" nl()
  nl()
  "% Reencode the font for IBMPC set of international chars" nl()
  "/encdict 12 dict def" nl()
  "/reenc {" nl()
  "  encdict begin" nl()
  "  /newenc exch def" nl()
  "  /nfont exch def" nl()
  "  /ofont exch def" nl()
  "  /ofontdict ofont findfont def" nl()
  "  /newfont ofontdict maxlength 1 add dict def" nl()
  "  ofontdict {" nl()
  "    exch dup /FID ne {" nl()
  "      dup /Encoding eq" nl()
  "       {exch dup length array copy newfont 3 1 roll put}" nl()
  "       {exch newfont 3 1 roll put} ifelse" nl()
  "    }" nl()
  "    {pop pop}" nl()
  "    ifelse" nl()
  "  } forall" nl()
  "  newfont /Fontname nfont put" nl()
  "  newenc aload pop" nl()
  "  newenc length 2 idiv" nl()
  "  { newfont /Encoding get 3 1 roll put}" nl()
  "  repeat" nl()
  "  nfont newfont definefont pop" nl()
  "  end" nl()
  "} def" nl()
  nl()
  "fontname /gedfont encvec reenc" nl()
  "/fontname /gedfont def" nl()
  "% end font reencoding" nl()
  nl()
  "/rl w maxlevel div def" nl()
  "/posunit h maxpos div def" nl()
  nl()
  "/posname 1.0 def" nl()
  "/posdate 0.75 def" nl()
  "/posmarg 0.3 def" nl()
  "/posbase posname posmarg 2 div add def" nl()
  nl()
  "/top h posunit posbase mul sub def" nl()
  nl()
  "% calculate base font size from segment length" nl()
  "/fntsize rl 9.0 div def" nl()
  nl()
  "% space for one individual" nl()
  "fntsize posunit gt {" nl()
  "  /fntsize posunit def" nl()
  "} if" nl()
  nl()
  "% font adjustment" nl()
  "/fntsize fntsize font_adjust mul def" nl()
  nl()
  "% font for birth/death dates" nl()
  "/fntsize2 fntsize posdate mul def" nl()
  nl()
  "fontname findfont fntsize scalefont setfont" nl()
  "/space ( ) stringwidth pop def" nl()
  nl()
  "% calc line width from segment length - .24 pts = 1 pixel" nl()
  "/linwid fntsize .1 mul .6 mul def" nl()
  "/linwid linwid linwidf mul def" nl()
  "linwid setlinewidth" nl()
  "/namey0 linwid fntsize 16.0 div add offset_name add def" nl()
  nl()
  "/dashwid rl 72 div def" nl()
  nl()
  "2 setlinecap" nl()
  nl()
  "% name string length for all generations" nl()
  "/len1 rl space indent 1 add mul sub def" nl()
  nl()
  "% show string given as argument" nl()
  "% select font size so that string fits in available length" nl()
  "/wshow {" nl()
  "  /s exch def" nl()
  "  /len exch def" nl()
  "  /fntsiz exch def" nl()
  "  bold direct and {" nl()
  "    boldfontname findfont fntsiz scalefont setfont" nl()
  "  } {" nl()
  "    fontname findfont fntsiz scalefont setfont" nl()
  "  } ifelse" nl()
  "  s stringwidth pop dup len lt {" nl()
  "    pop" nl()
  "  } {" nl()
  "    % compute new font size for exact fit" nl()
  "    len exch div fntsiz mul /fsize exch def" nl()
  "    bold direct and {" nl()
  "      boldfontname findfont fsize scalefont setfont" nl()
  "    } {" nl()
  "      fontname findfont fsize scalefont setfont" nl()
  "    } ifelse" nl()
  "  } ifelse" nl()
  "  direct {textcolr0} {textcolr1} ifelse" nl()
  "  s show" nl()
  "} bind def" nl()
  nl()
  "% called once for each individual on chart" nl()
  "/i {" nl()
  "  /duplic exch 1 eq def  % true for duplicate individual" nl()
  "  /direct exch 1 eq def  % true for direct ancestor" nl()
  "  /xhgt exch def         % extra height - not used here" nl()
  "  /pos exch def          % vertical position" nl()
  "  /level exch def        % generation level, 0 = youngest" nl()
  "  /marriage exch def     % marriage date" nl()
  "  /tagnote exch def      % tagged note from PAF" nl()
  "  /death exch def        % death date" nl()
  "  /birth exch def        % birth date" nl()
  "  /name exch def         % name" nl()
  nl()
  "  % x1 = left edge, x2 = right edge" nl()
  "  mirror {" nl()
  "    /x1 maxlevel level sub 1 sub rl mul def" nl()
  "    /x x1 space add def" nl()
  "  } {" nl()
  "    /x1 level rl mul def" nl()
  "    /x x1 space indent mul add def" nl()
  "  } ifelse" nl()
  "  /x2 x1 rl add def" nl()
  nl()
  "  /y top pos posunit mul sub def" nl()
  nl()
  "  direct {lincolr0} {lincolr1} ifelse" nl()
  nl()
  "  /namey namey0 def" nl()
  "  direct {" nl()
  "    bold {linwid 2.0 mul setlinewidth" nl()
  "          /namey namey linwid add def} if" nl()
  "    duplic {[dashwid dup currentlinewidth add] 0 setdash} if" nl()
  "    x1 y moveto x2 y lineto stroke" nl()
  "    duplic {[] 0 setdash} if" nl()
  "    bold {linwid setlinewidth} if" nl()
  "  } {" nl()
  "    duplic {[dashwid dup currentlinewidth add] 0 setdash} if" nl()
  "    mirror {" nl()
  "      x1 y moveto x2 space indent mul sub y lineto stroke" nl()
  "    } {" nl()
  "      x y moveto x2 y lineto stroke" nl()
  "    } ifelse" nl()
  "    duplic {[] 0 setdash} if" nl()
  "  } ifelse" nl()
  nl()
  "  % print name, birth date, death date" nl()
  "  x y namey add moveto" nl()
  "  fntsize len1 name wshow" nl()
  nl()
  "  birth length 0 gt {" nl()
  "    /y y fntsize2 sub def" nl()
  "    x y moveto" nl()
  "    fntsize2 len1 birth wshow" nl()
  "  } if" nl()
  "  death length 0 gt {" nl()
  "    /y y fntsize2 sub def" nl()
  "    x y moveto" nl()
  "    fntsize2 len1 death wshow" nl()
  "  } if" nl()
  "  marriage length 0 gt {" nl()
  "    /y y fntsize2 sub def" nl()
  "    x y moveto" nl()
  "    fntsize2 len1 marriage wshow" nl()
  "  } if" nl()
  "} bind def" nl()
  nl()
  "/l {" nl()
  "  /parent exch def" nl()
  "  /pos exch def" nl()
  "  /level exch def" nl()
  nl()
  "  mirror {" nl()
  "    /x maxlevel level sub 1 sub rl mul def" nl()
  "  } {" nl()
  "    /x level 1 add rl mul def" nl()
  "  } ifelse" nl()
  "  /y1 top pos posunit mul sub def" nl()
  "  /y2 top parent posunit mul sub def" nl()
  "  lincolr0" nl()
  "  bold {linwid 2.0 mul setlinewidth} if" nl()
  "  x y1 moveto x y2 lineto stroke" nl()
  "  bold {linwid setlinewidth} if" nl()
  "} bind def" nl()
}
